home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr53 / 117_01.zip / COPY.FTN < prev    next >
Text File  |  1993-06-22  |  12KB  |  375 lines
  1. C
  2. C COPY - COPY STANDARD INPUT TO STANDARD OUTPUT
  3.       INTEGER C, GETCH, DUMMY
  4. C
  5. 10    CONTINUE
  6. C                       10003 INDICATES AN EOF
  7.       IF (GETCH(C,DUMMY) .EQ. 10003)  GO TO 25
  8.       CALL PUTCH (C, DUMMY)
  9.       GO TO 10
  10. C
  11. 25    CONTINUE
  12. C
  13. C                      ALSO TEST REMARK
  14.       CALL REMARK (17HEND OF COPY TEST.)
  15.       CALL EXIT
  16.       END
  17. C
  18. C GETCH - GET CHARACTERS FROM FILE
  19. C
  20.        INTEGER FUNCTION GETCH(C, F)
  21.        INTEGER INMAP
  22.        INTEGER BUF(81), C
  23.        INTEGER F, I, LASTC
  24.        DATA LASTC /81/, BUF(81) /10/
  25. C
  26. C                      10 IS THE NEWLINE CHARACTER
  27.        IF(.NOT.(BUF(LASTC) .EQ. 10 .OR. LASTC .GE. 81))   GOTO 23114
  28. C                  CHANGE THE UNIT NUMBER IF NECESSARY
  29.        READ(5, 1, END=10) (BUF(I), I = 1, 80)
  30. 1      FORMAT(80 A1)
  31.        CONTINUE
  32.        I = 1
  33. 23116  IF(.NOT.( I .LE. 80))   GOTO 23118
  34.        BUF(I) = INMAP(BUF(I))
  35. 23117   I = I + 1
  36.        GOTO 23116
  37. 23118  CONTINUE
  38.        CONTINUE
  39.        I = 80
  40. 23119  IF(.NOT.( I .GT. 0)) GOTO 23121
  41. C                           32 IS BLANK
  42.        IF(.NOT.(BUF(I) .NE. 32))  GOTO 23122
  43.        GOTO 23121
  44. 23122  CONTINUE
  45. 23120   I = I - 1
  46.        GOTO 23119
  47. 23121  CONTINUE
  48. C                 10 IS NEWLINE
  49.        BUF(I+1) = 10
  50.        LASTC = 0
  51. 23114  CONTINUE
  52.        LASTC = LASTC + 1
  53.        C = BUF(LASTC)
  54.        GETCH = C
  55.        RETURN
  56. C          10003 IS END-OF-FILE MARKER
  57. 10     C = 10003
  58.        GETCH = 10003
  59.        RETURN
  60.        END
  61. C
  62. C PUTCH (INTERIM VERSION)  PUT CHARACTERS
  63. C
  64.        SUBROUTINE PUTCH(C, F)
  65.        INTEGER BUF(81), C
  66.        INTEGER OUTMAP
  67.        INTEGER F, I, LASTC
  68.        DATA LASTC /0/
  69. C
  70. C                        10 IS THE NEWLINE CHARACTER
  71.        IF(.NOT.(LASTC .GE. 81 .OR. C .EQ. 10))   GOTO 23342
  72.        IF(.NOT.( LASTC .LE. 0 ))  GOTO 23344
  73. C                 IF NECESSARY, CHANGE THE UNIT NUMBER IS THE
  74. C                 2 WRITE STATEMENTS IN THIS ROUTINE AND THE
  75. C                 1 IN REMARK
  76.        WRITE(6,2)
  77. 2      FORMAT(/)
  78.        GOTO 23345
  79. 23344  CONTINUE
  80.        WRITE(6, 1) (BUF(I), I = 1, LASTC)
  81. 1      FORMAT(80 A1)
  82. 23345  CONTINUE
  83.        LASTC = 0
  84. 23342  CONTINUE
  85. C                      10 IS NEWLINE
  86.        IF(.NOT.(C .NE. 10)) GOTO 23346
  87.        LASTC = LASTC + 1
  88.        BUF(LASTC) = OUTMAP(C)
  89. 23346  CONTINUE
  90.        RETURN
  91.        END
  92. C
  93. C REMARK - INTERIM VERSION
  94. C
  95.        SUBROUTINE REMARK(BUF)
  96.        INTEGER BUF(100), I
  97. C            DON'T WORRY ABOUT FINDING THE END OF THE BUF
  98. C            ARRAY JUST YET.  SIMPLY PRINT OUT 20 OR SO
  99. C            CHARACTERS IN WHATEVER FORMAT YOUR SYSTEM
  100. C            NEEDS FOR PRINTING HOLLERITH ARRAYS.
  101. C
  102. C                 YOU MIGHT HAVE THE CHANGE THE UNIT NUMBER
  103.        WRITE(6, 10) (BUF(I), I = 1, 10)
  104. 10     FORMAT(10A2)
  105.        RETURN
  106.        END
  107. C
  108. C INMAP - CONVERT LEFT ADJUSTED EXTERNAL REP TO RIGHT ADJ ASCII
  109. C
  110.        INTEGER FUNCTION INMAP(INCHAR)
  111.        INTEGER I, INCHAR
  112.        COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26),  E
  113.      *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33),  EXTBLK, INTBLK
  114.        INTEGER EXTDIG
  115.        INTEGER INTDIG
  116.        INTEGER EXTLET
  117.        INTEGER INTLET
  118.        INTEGER EXTBIG
  119.        INTEGER INTBIG
  120.        INTEGER EXTCHR
  121.        INTEGER INTCHR
  122.        INTEGER EXTBLK
  123.        INTEGER INTBLK
  124. C
  125. C                IS IT A BLANK?
  126.        IF(.NOT.(INCHAR .EQ. EXTBLK)) GOTO 23194
  127.        INMAP = INTBLK
  128.        RETURN
  129. 23194  CONTINUE
  130.        DO23196I = 1, 10
  131. C                IS IT A DIGIT?
  132.        IF(.NOT.(INCHAR .EQ. EXTDIG(I))) GOTO 23198
  133.        INMAP = INTDIG(I)
  134.        RETURN
  135. 23198  CONTINUE
  136. 23196  CONTINUE
  137. 23197  CONTINUE
  138. C                 IS IT A SMALL LETTER?
  139.        DO23200I = 1, 26
  140.        IF(.NOT.(INCHAR .EQ. EXTLET(I))) GOTO 23202
  141.        INMAP = INTLET(I)
  142.        RETURN
  143. 23202  CONTINUE
  144. 23200  CONTINUE
  145. 23201  CONTINUE
  146. C                 IS IT A CAPITAL LETTER?
  147.        DO23204I = 1, 26
  148.        IF(.NOT.(INCHAR .EQ. EXTBIG(I))) GOTO 23206
  149.        INMAP = INTBIG(I)
  150.        RETURN
  151. 23206  CONTINUE
  152. 23204  CONTINUE
  153. 23205  CONTINUE
  154. C               IS IT A SPECIAL CHARACTER?
  155.        DO23208I = 1, 33
  156.        IF(.NOT.(INCHAR .EQ. EXTCHR(I))) GOTO 23210
  157.        INMAP = INTCHR(I)
  158.        RETURN
  159. 23210  CONTINUE
  160. 23208  CONTINUE
  161. 23209  CONTINUE
  162. C               MUST BE SOMETHING ELSE
  163.        INMAP = INCHAR
  164.        RETURN
  165.        END
  166. C
  167. C
  168. C OUTMAP - CONVERT RIGHT ADJ ASCII TO LEFT ADJUSTED EXTERNAL REP
  169. C
  170.        INTEGER FUNCTION OUTMAP(INCHAR)
  171.        INTEGER I, INCHAR
  172.        COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26),  E
  173.      *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33),  EXTBLK, INTBLK
  174.        INTEGER EXTDIG
  175.        INTEGER INTDIG
  176.        INTEGER EXTLET
  177.        INTEGER INTLET
  178.        INTEGER EXTBIG
  179.        INTEGER INTBIG
  180.        INTEGER EXTCHR
  181.        INTEGER INTCHR
  182.        INTEGER EXTBLK
  183.        INTEGER INTBLK
  184. C
  185. C               IS IT A BLANK?
  186.        IF(.NOT.(INCHAR .EQ. INTBLK)) GOTO 23270
  187.        OUTMAP = EXTBLK
  188.        RETURN
  189. 23270  CONTINUE
  190. C               IS IT A DIGIT?
  191.        DO23272I = 1, 10
  192.        IF(.NOT.(INCHAR .EQ. INTDIG(I))) GOTO 23274
  193.        OUTMAP = EXTDIG(I)
  194.        RETURN
  195. 23274  CONTINUE
  196. 23272  CONTINUE
  197. 23273  CONTINUE
  198. C                IS IT A SMALL LETTER?
  199.        DO23276I = 1, 26
  200.        IF(.NOT.(INCHAR .EQ. INTLET(I))) GOTO 23278
  201.        OUTMAP = EXTLET(I)
  202.        RETURN
  203. 23278  CONTINUE
  204. 23276  CONTINUE
  205. 23277  CONTINUE
  206. C                   IS IT A CAPITAL LETTER?
  207.        DO23280I = 1, 26
  208.        IF(.NOT.(INCHAR .EQ. INTBIG(I))) GOTO 23282
  209.        OUTMAP = EXTBIG(I)
  210.        RETURN
  211. 23282  CONTINUE
  212. 23280  CONTINUE
  213. 23281  CONTINUE
  214. C                    IS IT A SPECIAL CHARACTER?
  215.        DO23284I = 1, 33
  216.        IF(.NOT.(INCHAR .EQ. INTCHR(I))) GOTO 23286
  217.        OUTMAP = EXTCHR(I)
  218.        RETURN
  219. 23286  CONTINUE
  220. 23284  CONTINUE
  221. 23285  CONTINUE
  222. C                 MUST BE SOMETHING ELSE
  223.        OUTMAP = INCHAR
  224.        RETURN
  225.        END
  226.  
  227. C
  228. C BLOCK DATA - INITIALIZE GLOBAL VARIABLES
  229. C
  230.        BLOCK DATA
  231.        COMMON /CCHAR/ EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26),  E
  232.      *XTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33),  EXTBLK, INTBLK
  233.        INTEGER EXTDIG
  234.        INTEGER INTDIG
  235.        INTEGER EXTLET
  236.        INTEGER INTLET
  237.        INTEGER EXTBIG
  238.        INTEGER INTBIG
  239.        INTEGER EXTCHR
  240.        INTEGER INTCHR
  241.        INTEGER EXTBLK
  242.        INTEGER INTBLK
  243.        DATA EXTBLK /1H /, INTBLK /32/
  244.        DATA EXTDIG(1) /1H0/, INTDIG(1) /48/
  245.        DATA EXTDIG(2) /1H1/, INTDIG(2) /49/
  246.        DATA EXTDIG(3) /1H2/, INTDIG(3) /50/
  247.        DATA EXTDIG(4) /1H3/, INTDIG(4) /51/
  248.        DATA EXTDIG(5) /1H4/, INTDIG(5) /52/
  249.        DATA EXTDIG(6) /1H5/, INTDIG(6) /53/
  250.        DATA EXTDIG(7) /1H6/, INTDIG(7) /54/
  251.        DATA EXTDIG(8) /1H7/, INTDIG(8) /55/
  252.        DATA EXTDIG(9) /1H8/, INTDIG(9) /56/
  253.        DATA EXTDIG(10) /1H9/, INTDIG(10) /57/
  254.        DATA EXTLET(1) /1Ha/, INTLET(1) /97/
  255.        DATA EXTLET(2) /1Hb/, INTLET(2) /98/
  256.        DATA EXTLET(3) /1Hc/, INTLET(3) /99/
  257.        DATA EXTLET(4) /1Hd/, INTLET(4) /100/
  258.        DATA EXTLET(5) /1He/, INTLET(5) /101/
  259.        DATA EXTLET(6) /1Hf/, INTLET(6) /102/
  260.        DATA EXTLET(7) /1Hg/, INTLET(7) /103/
  261.        DATA EXTLET(8) /1Hh/, INTLET(8) /104/
  262.        DATA EXTLET(9) /1Hi/, INTLET(9) /105/
  263.        DATA EXTLET(10) /1Hj/, INTLET(10) /106/
  264.        DATA EXTLET(11) /1Hk/, INTLET(11) /107/
  265.        DATA EXTLET(12) /1Hl/, INTLET(12) /108/
  266.        DATA EXTLET(13) /1Hm/, INTLET(13) /109/
  267.        DATA EXTLET(14) /1Hn/, INTLET(14) /110/
  268.        DATA EXTLET(15) /1Ho/, INTLET(15) /111/
  269.        DATA EXTLET(16) /1Hp/, INTLET(16) /112/
  270.        DATA EXTLET(17) /1Hq/, INTLET(17) /113/
  271.        DATA EXTLET(18) /1Hr/, INTLET(18) /114/
  272.        DATA EXTLET(19) /1Hs/, INTLET(19) /115/
  273.        DATA EXTLET(20) /1Ht/, INTLET(20) /116/
  274.        DATA EXTLET(21) /1Hu/, INTLET(21) /117/
  275.        DATA EXTLET(22) /1Hv/, INTLET(22) /118/
  276.        DATA EXTLET(23) /1Hw/, INTLET(23) /119/
  277.        DATA EXTLET(24) /1Hx/, INTLET(24) /120/
  278.        DATA EXTLET(25) /1Hy/, INTLET(25) /121/
  279.        DATA EXTLET(26) /1Hz/, INTLET(26) /122/
  280.        DATA EXTBIG(1) /1HA/, INTBIG(1) /65/
  281.        DATA EXTBIG(2) /1HB/, INTBIG(2) /66/
  282.        DATA EXTBIG(3) /1HC/, INTBIG(3) /67/
  283.        DATA EXTBIG(4) /1HD/, INTBIG(4) /68/
  284.        DATA EXTBIG(5) /1HE/, INTBIG(5) /69/
  285.        DATA EXTBIG(6) /1HF/, INTBIG(6) /70/
  286.        DATA EXTBIG(7) /1HG/, INTBIG(7) /71/
  287.        DATA EXTBIG(8) /1HH/, INTBIG(8) /72/
  288.        DATA EXTBIG(9) /1HI/, INTBIG(9) /73/
  289.        DATA EXTBIG(10) /1HJ/, INTBIG(10) /74/
  290.        DATA EXTBIG(11) /1HK/, INTBIG(11) /75/
  291.        DATA EXTBIG(12) /1HL/, INTBIG(12) /76/
  292.        DATA EXTBIG(13) /1HM/, INTBIG(13) /77/
  293.        DATA EXTBIG(14) /1HN/, INTBIG(14) /78/
  294.        DATA EXTBIG(15) /1HO/, INTBIG(15) /79/
  295.        DATA EXTBIG(16) /1HP/, INTBIG(16) /80/
  296.        DATA EXTBIG(17) /1HQ/, INTBIG(17) /81/
  297.        DATA EXTBIG(18) /1HR/, INTBIG(18) /82/
  298.        DATA EXTBIG(19) /1HS/, INTBIG(19) /83/
  299.        DATA EXTBIG(20) /1HT/, INTBIG(20) /84/
  300.        DATA EXTBIG(21) /1HU/, INTBIG(21) /85/
  301.        DATA EXTBIG(22) /1HV/, INTBIG(22) /86/
  302.        DATA EXTBIG(23) /1HW/, INTBIG(23) /87/
  303.        DATA EXTBIG(24) /1HX/, INTBIG(24) /88/
  304.        DATA EXTBIG(25) /1HY/, INTBIG(25) /89/
  305.        DATA EXTBIG(26) /1HZ/, INTBIG(26) /90/
  306. C
  307. C      SPECIAL CHARACTERS -- YOU MIGHT HAVE TO CHANGE SOME OF THESE
  308. C
  309.        DATA EXTCHR(1) /1H!/, INTCHR(1) /33/
  310. C                      EXCLAMATION POINT
  311.        DATA EXTCHR(2) /1H"/, INTCHR(2) /34/
  312. C                      DOUBLE QUOTE
  313.        DATA EXTCHR(3) /1H#/, INTCHR(3) /35/
  314. C                      POUND (NUMBER) SIGN
  315.        DATA EXTCHR(4) /1H$/, INTCHR(4) /36/
  316. C                      DOLLAR SIGN
  317.        DATA EXTCHR(5) /1H%/, INTCHR(5) /37/
  318. C                      PERCENT
  319.        DATA EXTCHR(6) /1H&/, INTCHR(6) /38/
  320. C                      AMPERSAND
  321.        DATA EXTCHR(7) /1H'/, INTCHR(7) /39/
  322. C                      SINGLE QUOTE
  323.        DATA EXTCHR(8) /1H(/, INTCHR(8) /40/
  324. C                      LEFT PAREN
  325.        DATA EXTCHR(9) /1H)/, INTCHR(9) /41/
  326. C                      RIGHT PAREN
  327.        DATA EXTCHR(10) /1H*/, INTCHR(10) /42/
  328. C                       ASTERISK
  329.        DATA EXTCHR(11) /1H+/, INTCHR(11) /43/
  330. C                       PLUS
  331.        DATA EXTCHR(12) /1H,/, INTCHR(12) /44/
  332. C                       COMMA
  333.        DATA EXTCHR(13) /1H-/, INTCHR(13) /45/
  334. C                       DASH (MINUS)
  335.        DATA EXTCHR(14) /1H./, INTCHR(14) /46/
  336. C                       PERIOD
  337.        DATA EXTCHR(15) /1H//, INTCHR(15) /47/
  338.        DATA EXTCHR(16) /1H:/, INTCHR(16) /58/
  339. C                       COLON
  340.        DATA EXTCHR(17) /1H;/, INTCHR(17) /59/
  341. C                       SEMICOLON
  342.        DATA EXTCHR(18) /1H</, INTCHR(18) /60/
  343. C                       LESS THAN (LEFT ANGLE BRACKET)
  344.        DATA EXTCHR(19) /1H=/, INTCHR(19) /61/
  345. C                       EQUALS
  346.        DATA EXTCHR(20) /1H>/, INTCHR(20) /62/
  347. C                       GREATER THAN (RIGHT ANGLE BRACKET)
  348.        DATA EXTCHR(21) /1H?/, INTCHR(21) /63/
  349. C                       QUESTION MARK
  350.        DATA EXTCHR(22) /1H@/, INTCHR(22) /64/
  351. C                       ATSIGN
  352.        DATA EXTCHR(23) /1H[/, INTCHR(23) /91/
  353. C                      LEFT BRACKET
  354.        DATA EXTCHR(24) /1H\/, INTCHR(24) /92/
  355. C                     BACKSLASH
  356.        DATA EXTCHR(25) /1H]/, INTCHR(25) /93/
  357. C                    RIGHT BRACKET
  358.        DATA EXTCHR(26) /1H_/, INTCHR(26) /95/
  359. C                    UNDERSCORE
  360.        DATA EXTCHR(27) /1H{/, INTCHR(27) /123/
  361. C                    LEFT BRACE
  362.        DATA EXTCHR(28) /1H|/, INTCHR(28) /124/
  363. C                    VERTICAL BAR
  364.        DATA EXTCHR(29) /1H}/, INTCHR(29) /125/
  365. C                    RIGHT BRACE
  366.        DATA EXTCHR(30) /1H/, INTCHR(30) /8/
  367. C                   BACKSPACE   (CONTROL-H)
  368.        DATA EXTCHR(31) /1H    /, INTCHR(31) /9/
  369. C                   TAB (CONTROL-I)
  370.        DATA EXTCHR(32) /1H^/, INTCHR(32) /94/
  371. C                   CARET (UP-ARROW)
  372.        DATA EXTCHR(33) /1H~/, INTCHR(33) /126/
  373. C                   TILDE
  374.        END
  375.